PD ROM 1/PD ROM Volume I - Macintosh Software from BMUG (1988).iso/Programming/Programming Tools/Turbo Pascal/Utilities/DEARC5.PAS

Pascal/Delphi Source File | 1987-06-16 | 23.5 KB | 969 lines | [TEXT/ttxt]

{$R-}

program dearc512;

{ DEARC.PAS - Program to extract all files from an archive created by version
  5.12 or earlier of the ARC utility.

  ARC is COPYRIGHT 1985 by System Enhancement Associates.

  This program requires Turbo Pascal for the Mac Version 1.00.

  Usage:

     Open or double-click the DEARC application.


   *** ORIGINAL AUTHOR UNKNOWN ***

  Version 1.01 - 10/19/85. Changed end-of-file processing to, hopefully, be
                           more compatible with CPM (whatever that is).
  Version 1.01A - 12/19/85 By Roy Collins
                           Mail: TechMail BBS @ 703-430-2535
                                 - or -
                                 P.O.Box 1192, Leesburg, Va 22075
                           Modified V1.01 to work with Turbo Pascal Version 2
                           Added functions ARGC (argument count) and ARGV
                           (argument value)
                           Modified all references to "EXIT" command to be
                           GOTO EXIT, with EXIT defined as a LABEL, at the
                           end of the function/procedure involved.
                           Will not accept path names - archives must be in
                           the current directory.
  Version 2.00 - 6/11/86   By David W. Carroll
                           Mail: High Sierra RBBS-PC @ 209/296-3534
                           Now supports ARC version 5.12 files, compression
                           types 7 and 8.

  Version m2.00 - 87/03/22 By Mike Babulic.
                           Compuserve ID: 72307,314
                           A fast & dirty port to Macintosh Turbo Pascal.
                           Someone should "Macintize" this properly by using
                           "ALERT"s for the error messages, an "About Dearc..."
                           menu item & use CountAppFiles (etc.) to open the
                           files to be "dearced". I may get around to it if I
                           find the time.
}

{$U FileUt}
USES MemTypes,QuickDraw,OSIntf,ToolIntf,PackIntf,FileUt;

function Num2String(n:LongInt):str255;
  var s : str255;
  begin
    NumToString(n,s);
    Num2String := s;
  end;

(************ Useful utility to make stuffing easier ***************)

var StuffPos : LongInt;

procedure StuffIt(p:Ptr; s:Str255);
  begin
    StuffHex(p,s);
    StuffPos := Length(s) shr 1 + LongInt(p);
  end;

procedure StuffMore(s:Str255);
  begin
    StuffHex(Ptr(StuffPos),s);
    StuffPos := Length(s) shr 1 + StuffPos;
  end;

(*******************************************************************)

const BLOCKSIZE = 128;
      arcmarc   = 26;              { special archive marker }
      arcver    = 8;               { max archive header version code }
      strlen    = 100;             { standard string length }
      fnlen     = 12;              { file name length - 1 }

var  crctab : array [0..255] of integer; {MGB 86/02/28}

procedure init_crctab;
begin
    StuffIt(@crctab,'0000C0C1C1810140C30103C00280C241');
    StuffMore('C60106C00780C7410500C5C1C4810440');
    StuffMore('CC010CC00D80CD410F00CFC1CE810E40');
    StuffMore('0A00CAC1CB810B40C90109C00880C841');
    StuffMore('D80118C01980D9411B00DBC1DA811A40');
    StuffMore('1E00DEC1DF811F40DD011DC01C80DC41');
    StuffMore('1400D4C1D5811540D70117C01680D641');
    StuffMore('D20112C01380D3411100D1C1D0811040');
    StuffMore('F00130C03180F1413300F3C1F2813240');
    StuffMore('3600F6C1F7813740F50135C03480F441');
    StuffMore('3C00FCC1FD813D40FF013FC03E80FE41');
    StuffMore('FA013AC03B80FB413900F9C1F8813840');
    StuffMore('2800E8C1E9812940EB012BC02A80EA41');
    StuffMore('EE012EC02F80EF412D00EDC1EC812C40');
    StuffMore('E40124C02580E5412700E7C1E6812640');
    StuffMore('2200E2C1E3812340E10121C02080E041');
    StuffMore('A00160C06180A1416300A3C1A2816240');
    StuffMore('6600A6C1A7816740A50165C06480A441');
    StuffMore('6C00ACC1AD816D40AF016FC06E80AE41');
    StuffMore('AA016AC06B80AB416900A9C1A8816840');
    StuffMore('7800B8C1B9817940BB017BC07A80BA41');
    StuffMore('BE017EC07F80BF417D00BDC1BC817C40');
    StuffMore('B40174C07580B5417700B7C1B6817640');
    StuffMore('7200B2C1B3817340B10171C07080B041');
    StuffMore('500090C191815140930153C052809241');
    StuffMore('960156C057809741550095C194815440');
    StuffMore('9C015CC05D809D415F009FC19E815E40');
    StuffMore('5A009AC19B815B40990159C058809841');
    StuffMore('880148C0498089414B008BC18A814A40');
    StuffMore('4E008EC18F814F408D014DC04C808C41');
    StuffMore('440084C185814540870147C046808641');
    StuffMore('820142C043808341410081C180814040');
  end;

type long    = LongInt;
              (*record           { used to simulate long (4 byte) integers }
                 l, h : integer
               end;*)

(***** Useful utility to convert 8086 integers to 68000 format ****)

function Int86(i:integer):integer;
  begin
    Int86 := swap(i);
  end;

function Long86(i:Long):LongInt;
  type Long = record h,l :integer end;
  var t : integer;
  begin
    with long(i) do begin
      h := swap(h); l := swap(l);
    end;
    Long86 := swapword(i);
  end;

(******************************************************************)

type strtype = string[strlen];
     fntype  = packed array [0..fnlen] of char;
     buftype = packed array [1..BLOCKSIZE] of byte;
     heads   = packed record
                 name   : fntype;
                 size   : long;
                 date   : integer;
                 time   : integer;
                 crc    : integer;
                 length : long
               end;

var hdrver   : byte;
    arcfile  : UntypedFile;
    arcbuf   : buftype;
    arcname  : strtype;
    arcptr   : integer;
    endfile  : boolean;

    extfile  : Text;
    extname  : strtype;

{ definitions for unpack }

const DLE = $90;

var state  : (NOHIST, INREP);
    crcval : integer;
    size   : LongInt;
    lastc  : integer;

{ definitions for unsqueeze }

const ERROR   = -1;
      SPEOF   = 256;
      NUMVALS = 256;               { 1 less than the number of values }

type nd = record
            child : packed array [0..1] of integer
          end;

var node     : packed array [0..NUMVALS] of nd;
    bpos     : integer;
    curin    : integer;
    numnodes : integer;

{ definitions for uncrunch }

const TABSIZE   = 4096;
      TABSIZEM1 = 4095;
      NO_PRED   = $FFFF;
      EMPTY     = $FFFF;

type entry = PACKED record
               used         : boolean;
               next         : integer;
               predecessor  : integer;
               follower     : byte;
             end;

var stack       : packed array [0..TABSIZEM1] of byte;
    sp          : integer;
  type string_tab_type = packed array [0..TABSIZEM1] of entry;
       string_tab_ptr = ^string_tab_type;
var  string_tab  : string_tab_ptr;

var code_count : integer;
    code       : integer;
    firstc     : boolean;
    oldcode    : integer;
    finchar    : integer;
    inbuf      : integer;
    outbuf     : integer;
    newhash    : boolean;

{ definitions for dynamic uncrunch }

const
  BITS = 12;
  HSIZE = 5003;
  INIT_BITS = 9;
  FIRST = 257;
  CLEAR = 256;
  HSIZEM1 = 5002;
  BITSM1 = 11;

var
  RMASK : packed array[0..8] of byte;{MGB 87/02/28 =
  ($00, $01, $03, $07, $0f, $1f, $3f, $7f, $ff);}

type
  prefix_type = packed array[0..HSIZEM1] of integer;
  suffix_type = packed array[0..TABSIZEM1] of byte;

var
  n_bits,
  maxcode : integer;
  prefix : ^prefix_type;
  suffix : ^suffix_type;
  buf : packed array[0..BITS] of byte;
    {MGB 87/03/22 was origionally [0..BITSM1]
       BUG WAS NOT DETECTED because of $R- (range checking was turned off)}
  clear_flg : integer;
  stack1 : packed array[0..HSIZEM1] of byte;
  free_ent : integer;
  maxcodemax : integer;
  offset, sizex : integer;
  firstch : boolean;

procedure abort(s : strtype);
{ terminate the program with an error message }
begin
  writeln('ABORT: ', s);
  close(arcfile);
  close(extfile);
  repeat until keypressed;
  halt;
end; (* proc abort *)

function fn_to_str(var fn : fntype) : strtype;
{ convert strings from C format (trailing 0) to Turbo Pascal format (leading
    length byte). }
var s : strtype;
    i : integer;
begin
  s := '';
  i := 0;
  while fn[i] <> #0 do begin
    s := s + fn[i];
    i := i + 1
    end;
  fn_to_str := s
end; (* func fn_to_str *)

procedure Read_Block;
{ read a block from the archive file }
  var blocksRead,nd,pos : LongInt;
begin
  if EOF(arcfile) then
    endfile := TRUE
  else
    BlockRead(arcfile, arcbuf, 1, blocksRead);
  arcptr := 1
end; (* proc read_block *)

function open_arc:boolean;
{ open the archive file for input processing }
var ok : boolean;
begin
  ok := SFGetReset(arcfile,BLOCKSIZE,'');
  if ok then begin
    arcname := SFDialog.r.fname;
    endfile := FALSE;
    Read_Block;
    end
  else begin
    arcname := '';
    endfile := TRUE;
  end;
  open_arc := ok;
end; (* proc open_arc *)

function open_ext:Boolean;
{ open the extracted file for writing }
begin
  open_ext := SFPutRewrite(extfile,TextFile,extname);
  extname := SFDialog.r.fname;
end; (* proc open_ext *)

function get_arc : byte;
{ read 1 character from the archive file }
begin
  if endfile then
    get_arc := 0
  else begin
    get_arc := arcbuf[arcptr];
    if arcptr = BLOCKSIZE then
      Read_Block
    else
      arcptr := succ(arcptr)
  end

end; (* func get_arc *)

procedure put_ext(c : byte);
{ write 1 character to the extracted file }
begin
  write(extfile,char(c));
end; (* proc put_ext *)

procedure close_arc;
{ close the archive file }
begin
  close(arcfile)
end; (* proc close_arc *)

procedure close_ext;
{ close the extracted file }
begin
  close(extfile)
end; (* proc close_ext *)

procedure fseek(offset : LongInt; base : integer);
{ re-position the current pointer in the archive file }
var b           : LongInt;
    i, ofs, rec : integer;
    c           : byte;
begin
  case base of
    0 : b := offset;
    1 : b := offset + (FilePos(arcfile) - 1) * BLOCKSIZE
              + arcptr - 1;
    2 : b := offset + FileSize(arcfile) * BLOCKSIZE - 1
    otherwise
      abort('Invalid parameters to fseek')
    end;
  rec := b DIV BLOCKSIZE;
  ofs := b - (rec * BLOCKSIZE);
  seek(arcfile, rec);
  Read_Block;
  for i := 1 to ofs do
    c := get_arc
end; (* proc fseek *)

procedure fread(var buf; reclen : integer);
{ read a record from the archive file }
type buftype = packed array [1..MaxInt] of byte;
var i : integer;
    b : ^buftype;
begin
  b := @buf;
  if (reclen = SizeOf(Integer)) or (reclen = sizeof(LongInt)) then
    for i := reclen downto 1 do {68000 integers are H,L}
      b^[i] := get_arc          { 80xx integers are L,H}
  else
    for i := 1 to reclen do
      b^[i] := get_arc;
end; (* proc fread *)

function readhdr(var hdr : heads) : boolean;
{ read a file header from the archive file }
{ FALSE = eof found; TRUE = header found }
label exit;
var name : fntype;
    try  : integer;
begin
  try := 10;
  readhdr := FALSE;
  if endfile then
    goto exit ;              (******** was "exit" ************)

  while get_arc <> arcmarc do begin
    if try = 0 then
      abort(arcname + ' is not an archive');
    try := try - 1;
    writeln(arcname, ' is not an archive, or is out of sync');
    if endfile then
      abort('Archive length error')
    end; (* while *)

  hdrver := get_arc;
  if hdrver < 0 then
    abort('Invalid header in archive ' + arcname);
  if hdrver = 0 then   { special end of file marker }
    goto exit;               (******** was "exit" ************)

  if hdrver > arcver then begin
    fread(name, fnlen);
    writeln('I dont know how to handle file ', fn_to_str(name),
            ' in archive ', arcname);
    writeln('I think you need a newer version of DEARC.');
    halt;
    end;

  fread(hdr.name,fnlen+1);
  if hdrver = 1 then begin
    fread(hdr.size, sizeof(heads) - sizeof(hdr.name) - sizeof(long));
    hdrver := 2;
    hdr.length := hdr.size
    end
  else
    fread(hdr.size, sizeof(heads) - sizeof(hdr.name));

  readhdr := TRUE;

  {Convert to 68000 integers}
    with hdr do begin
      size  := long86(size);
      date  :=  int86(date);
      time  :=  int86(time);
      crc   :=  int86(crc);
      length:= long86(length);
    end;
exit:
end; (* func readhdr *)

procedure putc_unp(c : integer);
begin
  crcval := ((crcval shr 8) and $00FF) xor crctab[(crcval xor c) and $00FF];
  put_ext(c)
end; (* proc putc_unp *)

procedure putc_ncr(c : integer);
begin
  case state of
    NOHIST : if c = DLE then
               state := INREP
             else begin
               lastc := c;
               putc_unp(c)
               end;
    INREP  : begin
             if c = 0 then
               putc_unp(DLE)
             else begin
               c := c - 1;
               while (c <> 0) do begin
                 putc_unp(lastc);
                 c := c - 1
                 end
               end;
             state := NOHIST
             end;
    end; (* case *)
end; (* proc putc_ncr *)

function getc_unp : integer;
begin
  if size = 0 then
    getc_unp := -1
  else begin
    size := size - 1;
    getc_unp := get_arc;
    end;
end; (* func getc_unp *)

procedure init_usq;
{ initialize for unsqueeze }
var i : integer;
begin
  bpos := 99;
  fread(numnodes, sizeof(numnodes));
  if (numnodes < 0) or (numnodes > NUMVALS) then
    abort('File has an invalid decode tree');
  node[0].child[0] := -(SPEOF + 1);
  node[0].child[1] := -(SPEOF + 1);
  for i := 0 to numnodes-1 do begin
    fread(node[i].child[0], sizeof(integer));
    fread(node[i].child[1], sizeof(integer))
    end;
end; (* proc init_usq; *)

function getc_usq : integer;
{ unsqueeze }
label exit;
var i : integer;
begin
  i := 0;
  while i >= 0 do begin
    bpos := bpos + 1;
    if bpos > 7 then begin
      curin := getc_unp;
      if curin = ERROR then begin
        getc_usq := ERROR;
        goto exit                   (******** was "exit" ************)
        end;
      bpos := 0;
      i := node[i].child[1 and curin]
      end
    else begin
      curin := curin shr 1;
      i := node[i].child[1 and curin]
      end
    end; (* while *)
  i := - (i + 1);
  if i = SPEOF then
    getc_usq := -1
  else
    getc_usq := i;
  exit:
end; (* func getc_usq *)

function h(pred, foll : integer) : integer; {MGB 87/02/28}
{ calculate hash value }
  var Local,p,f: LongInt;
  begin
    p := BitAnd(pred,$FFFF);  f := BitAnd(foll,$FFFF);
    if newhash then
      Local := (p + f) * 15073
    else begin
      Local := BitOr(p + f, $0800);
      Local := BitShift(Local*Local,-6);
    end;
    h := BitAnd(Local,$0FFF);
  end; (* func h *)

function eolist(index : integer) : integer;
var temp : integer;
begin
  temp := string_tab^[index].next;
  while temp <> 0 do begin
    index := temp;
    temp := string_tab^[index].next
    end;
  eolist := index
end; (* func eolist *)

function hash(pred, foll : integer) : integer;
var local     : integer;
    tempnext  : integer;
begin
  local := h(pred, foll);
  if not string_tab^[local].used then
    hash := local
  else begin
    local := eolist(local);
    tempnext := (local + 101) and $0FFF;
    while string_tab^[tempnext].used do begin
      tempnext := tempnext + 1;
      if tempnext = TABSIZE then
        tempnext := 0
      end;
    string_tab^[local].next := tempnext;
    hash := tempnext
    end;
end; (* func hash *)

procedure upd_tab(pred, foll : integer);
begin
  with string_tab^[hash(pred, foll)] do begin
    used := TRUE;
    next := 0;
    predecessor := pred;
    follower := lo(foll)
    end
end; (* proc upd_tab *)

function gocode : integer;
label exit;
var localbuf  : integer;
    returnval : integer;
begin
  if inbuf = EMPTY then begin
    localbuf := getc_unp;
    if localbuf = -1 then begin
      gocode := -1;
      goto exit                       (******** was "exit" ************)
      end;
    localbuf := localbuf and $00FF;
    inbuf := getc_unp;
    if inbuf = -1 then begin
      gocode := -1;
      goto exit                       (******** was "exit" ************)
      end;
    inbuf := inbuf and $00FF;
    returnval := ((localbuf shl 4) and $0FF0) + ((inbuf shr 4) and $000F);
    inbuf := inbuf and $000F
    end
  else begin
    localbuf := getc_unp;
    if localbuf = -1 then begin
      gocode := -1;
      goto exit                       (******** was "exit" ************)
      end;
    localbuf := localbuf and $00FF;
    returnval := localbuf + ((inbuf shl 8) and $0F00);
    inbuf := EMPTY
    end;
  gocode := returnval;
exit:
end; (* func gocode *)

procedure push(c : integer);
begin
  stack[sp] := c;
  sp := sp + 1;
  if sp >= TABSIZE then
    abort('Stack overflow')
end; (* proc push *)

function pop : integer;
begin
  if sp > 0 then begin
    sp := sp - 1;
    pop := stack[sp]
  end else
    pop := EMPTY
end; (* func pop *)

procedure init_tab;
var i : integer;
begin
  FillChar(string_tab^, sizeof(string_tab^), 0);
  for i := 0 to 255 do
    upd_tab(NO_PRED, i);
  inbuf := EMPTY;
  { outbuf := EMPTY }
end; (* proc init_tab *)

procedure init_ucr(i:integer);
begin
  newhash := i = 1;
  sp := 0;
  init_tab;
  code_count := TABSIZE - 256;
  firstc := TRUE
end; (* proc init_ucr *)

function getc_ucr : integer;
label exit;
var c       : integer;
    code    : integer;
    newcode : integer;
begin
  if firstc then begin
    firstc := FALSE;
    oldcode := gocode;
    finchar := string_tab^[oldcode].follower;
    getc_ucr := finchar;
    goto exit                         (******** was "exit" ************)
    end;
  if sp = 0 then begin
    newcode := gocode;
    code := newcode;
    if code = -1 then begin
      getc_ucr := -1;
      goto exit                       (******** was "exit" ************)
      end;
    if not string_tab^[code].used then begin
      code := oldcode;
      push(finchar)
      end;
    while string_tab^[code].predecessor <> NO_PRED do
      with string_tab^[code] do begin
        push(follower);
        code := predecessor
        end;
    finchar := string_tab^[code].follower;
    push(finchar);
    if code_count <> 0 then begin
      upd_tab(oldcode, finchar);
      code_count := code_count - 1
      end;
    oldcode := newcode
    end;
  getc_ucr := pop;
exit:
end; (* func getc_ucr *)

function getcode : integer;
label
  next, exit;
var
  code, r_off, bitsx : integer;        dummy:char;
  bp : byte;
begin
  if firstch then
  begin
    offset := 0;
    sizex := 0;
    firstch := false;
  end;
  bp := 0;
  if (clear_flg > 0) or (offset >= sizex) or (free_ent > maxcode) then
  begin
    if free_ent > maxcode then
    begin
      n_bits := n_bits + 1;
      if n_bits = BITS then
        maxcode := maxcodemax
      else
        maxcode := (1 shl n_bits) - 1;
    end;
    if clear_flg > 0 then
    begin
      n_bits := INIT_BITS;
      maxcode := (1 shl n_bits) - 1;
      clear_flg := 0;
    end;
    for sizex := 0 to n_bits-1 do
    begin
      code := getc_unp;
      if code = -1 then
        goto next
      else
        buf[sizex] := code;
    end;
    sizex := sizex + 1;
next:
    if sizex <= 0 then
    begin
      getcode := -1;
      goto exit;
    end;
    offset := 0;
    sizex := (sizex shl 3) - (n_bits - 1);
  end;
  r_off := offset;
  bitsx := n_bits;

  { get first byte }
  bp := lo(bp + (r_off shr 3));
  r_off := r_off and 7;

  { get first parft (low order bits) }
  code := buf[bp] shr r_off;
  bp := bp + 1;
  bitsx := bitsx - (8 - r_off);
  r_off := 8 - r_off;

  if bitsx >= 8 then
  begin
    code := code or (buf[bp] shl r_off);
    bp := bp + 1;
    r_off := r_off + 8;
    bitsx := bitsx - 8;
  end;

  code := code or ((buf[bp] and rmask[bitsx]) shl r_off);
  offset := offset + n_bits;
  getcode := code;
exit:
end;

procedure decomp;
label
  next,exit;
var
  stackp,
  finchar :integer;
  code, oldcode, incode : integer;

begin
  { INIT var }
  if firstch then
    maxcodemax := 1 shl bits;

  code := getc_unp;
  if code <> BITS then
  begin
    abort('File packed with '+Num2String(code)+' bits, I can only handle '+Num2String(BITS));
  end;
  clear_flg := 0;

  n_bits := INIT_BITS;
  maxcode := (1 shl n_bits ) - 1;
  for code := 255 downto 0 do
  begin
    prefix^[code] := 0;
    suffix^[code] := code;
  end;

  free_ent := FIRST;
  oldcode := getcode;
  finchar := oldcode;
  if oldcode = -1 then
    goto exit;
  putc_ncr(finchar);
  stackp := 0;

  code := getcode;
  while code  > -1 do
  begin
    if code = CLEAR then
    begin
      for code := 255 downto 0 do
        prefix^[code] := 0;
      clear_flg := 1;
      free_ent := FIRST - 1;
      code := getcode;
      if code = -1 then
        goto next;
    end;
next:
    incode := code;
    if code >= free_ent then
    begin
      stack1[stackp] := finchar;
      stackp := stackp + 1;
      code := oldcode;
    end;
    while code >= 256 do
    begin
      stack1[stackp] := suffix^[code];
      stackp := stackp + 1;
      code := prefix^[code];
    end;
    finchar := suffix^[code];
    stack1[stackp] := finchar;
    stackp := stackp + 1;
    repeat
      stackp := stackp - 1;
      putc_ncr(stack1[stackp]);
    until stackp <= 0;
    code := free_ent;
    if code < maxcodemax then
    begin
      prefix^[code] := oldcode;
      suffix^[code] := finchar;
      free_ent := code + 1;
    end;
    oldcode := incode;
    code := getcode;
  end;
exit:
end;

procedure unpack(var hdr : heads);
label exit;
var c : integer;
begin
  crcval := 0;
  size := hdr.size;
  state := NOHIST;
  case hdrver of
    1, 2 : begin
           c := getc_unp;
           while c <> -1 do begin
             putc_unp(c);
             c := getc_unp
             end
           end;
    3    : begin
           c := getc_unp;
           while c <> -1 do begin
             putc_ncr(c);
             c := getc_unp
             end
           end;
    4    : begin
           init_usq;
           c := getc_usq;
           while c <> -1 do begin
             putc_ncr(c);
             c := getc_usq
             end
           end;
    5    : begin
           init_ucr(0);
           c := getc_ucr;
           while c <> -1 do begin
             putc_unp(c);
             c := getc_ucr
             end
           end;
    6    : begin
           init_ucr(0);
           c := getc_ucr;
           while c <> -1 do begin
             putc_ncr(c);
             c := getc_ucr
             end
           end;
    7    : begin
           init_ucr(1);
           c := getc_ucr;
           while c <> -1 do begin
             putc_ncr(c);
             c := getc_ucr
             end
           end;

    8    : begin
             decomp;
           end;
    otherwise
           writeln('I dont know how to unpack file ', fn_to_str(hdr.name));
           writeln('I think you need a newer version of DEARC');
           fseek(hdr.size, 1);
           goto exit                         (******** was "exit" ************)
    end; (* case *)
  if crcval <> hdr.crc then
    writeln('WARNING: File ', fn_to_str(hdr.name), ' fails CRC check');
exit:
end; (* proc unpack *)

procedure extract_file(var hdr : heads);
begin
  extname := fn_to_str(hdr.name);
  if open_ext then begin
    unpack(hdr);
    close_ext
    end
  else
    fseek(hdr.size,1);
end; (* proc extract *)

procedure extarc;
var hdr : heads;
begin
  if open_arc then begin
    while readhdr(hdr) do
      extract_file(hdr);
    close_arc
    end
  else begin
    if FileErr<>noErr then
      abort('Didn''t open ARC file. FileErr='+Num2String(FileErr));
  end;
end; (* proc extarc *)

procedure PrintHeading;
begin
  writeln;
  writeln('Turbo Pascal DEARC Utility');
  writeln('Version 2.0, 6/11/86');
  writeln('Supports ARC version 5.12 files');
  writeln;
end; (* proc PrintHeading *)

procedure init_vars;
  begin
    init_crctab;
    StuffIt(@RMASK,'000103070F1F3F7FFF');
    New(string_tab);
    New(prefix);
    New(suffix);
  end;

begin
  init_vars;
  firstch := true;
  PrintHeading; { print a heading }
  extarc;       { extract all files from the archive }
end.